home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / pictool.cls < prev    next >
Text File  |  1997-06-14  |  12KB  |  370 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "GPicTool"
  6. Attribute VB_GlobalNameSpace = True
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Private Declare Sub OleCreatePictureIndirect Lib "olepro32.dll" ( _
  13.     lpPictDesc As PICTDESC, riid As IID, _
  14.     ByVal fPictureOwnsHandle As Long, ipic As IPicture)
  15.  
  16. Private dxyShell As Long
  17.  
  18. Public Enum EErrorPicTool
  19.     eeBasePicTool = 13560   ' PicTool
  20. End Enum
  21.  
  22. Public Enum EIconSize
  23.     eisDefault = -1
  24.     eisImage = -2
  25.     eisSmall = -3
  26.     eisHuge = -4
  27.     eisShell = -5
  28. End Enum
  29.  
  30. Public Enum EConversions
  31.     TwipsPerPoint = 20
  32.     TwipsPerCharX = 120
  33.     TwipsPerCharY = 240
  34.     TwipsPerInch = 1440
  35.     TwipsPerDecimeter = 5669
  36. End Enum
  37.  
  38. '' Scale conversion procedures
  39.  
  40. #If fComponent Then
  41. ' Public for global class
  42. Function TwipsPerCentimeter() As Single
  43.     TwipsPerCentimeter = 566.9
  44. End Function
  45.  
  46. Function TwipsPerMillimeter() As Single
  47.     TwipsPerMillimeter = 56.69
  48. End Function
  49.  
  50. Function TwipsPerHiMetricUnit() As Single
  51.     TwipsPerHiMetricUnit = 0.5669
  52. End Function
  53. #Else
  54. ' Public for standard module (incorrectly marked as error in global class)
  55. Public Const TwipsPerCentimeter = 566.9
  56. Public Const TwipsPerMillimeter = 56.69
  57. Public Const TwipsPerHiMetricUnit = 0.5669
  58. #End If
  59.  
  60. Function PicXToPixel(ByVal xHiMetric As Long) As Long
  61.     PicXToPixel = xHiMetric * TwipsPerDecimeter / Screen.TwipsPerPixelX / 10000
  62. End Function
  63.  
  64. Function PicYToPixel(ByVal yHiMetric As Long) As Long
  65.     PicYToPixel = yHiMetric * TwipsPerDecimeter / Screen.TwipsPerPixelY / 10000
  66. End Function
  67.  
  68. '' Picture conversion procedures
  69.  
  70. Function IconToPicture(ByVal hIcon As Long) As IPicture
  71.     If hIcon = hNull Then Exit Function
  72.     Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
  73.     ' Fill picture description
  74.     picdes.cbSizeofstruct = Len(picdes)
  75.     picdes.picType = vbPicTypeIcon
  76.     picdes.hgdiobj = hIcon
  77.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  78.     iidIPicture.Data1 = &H7BF80980
  79.     iidIPicture.Data2 = &HBF32
  80.     iidIPicture.Data3 = &H101A
  81.     iidIPicture.Data4(0) = &H8B
  82.     iidIPicture.Data4(1) = &HBB
  83.     iidIPicture.Data4(2) = &H0
  84.     iidIPicture.Data4(3) = &HAA
  85.     iidIPicture.Data4(4) = &H0
  86.     iidIPicture.Data4(5) = &H30
  87.     iidIPicture.Data4(6) = &HC
  88.     iidIPicture.Data4(7) = &HAB
  89.     ' Create picture from icon handle
  90.     OleCreatePictureIndirect picdes, iidIPicture, True, ipic
  91.     ' Result will be valid Picture or Nothing--either way set it
  92.     Set IconToPicture = ipic
  93. End Function
  94.  
  95. Function CursorToPicture(ByVal hIcon As Long) As IPicture
  96.     ' It's just an alias
  97.     Set CursorToPicture = IconToPicture(hIcon)
  98. End Function
  99.  
  100. Function BitmapToPicture(ByVal hBmp As Long, _
  101.                          Optional ByVal hPal As Long = hNull) _
  102.                          As IPicture
  103.     ' Fill picture description
  104.     Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
  105.     picdes.cbSizeofstruct = Len(picdes)
  106.     picdes.picType = vbPicTypeBitmap
  107.     picdes.hgdiobj = hBmp
  108.     picdes.hPalOrXYExt = hPal
  109.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  110.     iidIPicture.Data1 = &H7BF80980
  111.     iidIPicture.Data2 = &HBF32
  112.     iidIPicture.Data3 = &H101A
  113.     iidIPicture.Data4(0) = &H8B
  114.     iidIPicture.Data4(1) = &HBB
  115.     iidIPicture.Data4(2) = &H0
  116.     iidIPicture.Data4(3) = &HAA
  117.     iidIPicture.Data4(4) = &H0
  118.     iidIPicture.Data4(5) = &H30
  119.     iidIPicture.Data4(6) = &HC
  120.     iidIPicture.Data4(7) = &HAB
  121.     ' Create picture from bitmap handle
  122.     OleCreatePictureIndirect picdes, iidIPicture, True, ipic
  123.     ' Result will be valid Picture or Nothing--either way set it
  124.     Set BitmapToPicture = ipic
  125. End Function
  126.  
  127. Function MetafileToPicture(ByVal hMeta As Long, _
  128.                            ByVal xExt As Integer, _
  129.                            ByVal yExt As Integer, _
  130.                            Optional fOld As Boolean) As IPicture
  131.     If hMeta = hNull Then Exit Function
  132.     Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
  133.     ' Fill picture description (assume enhanced)
  134.     picdes.cbSizeofstruct = Len(picdes)
  135.     If fOld Then
  136.         picdes.picType = vbPicTypeMetafile
  137.     Else
  138.         picdes.picType = vbPicTypeEMetafile
  139.     End If
  140.     picdes.hgdiobj = hMeta
  141.     picdes.hPalOrXYExt = MBytes.MakeDWord(xExt, yExt) ' Fake union
  142.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  143.     iidIPicture.Data1 = &H7BF80980
  144.     iidIPicture.Data2 = &HBF32
  145.     iidIPicture.Data3 = &H101A
  146.     iidIPicture.Data4(0) = &H8B
  147.     iidIPicture.Data4(1) = &HBB
  148.     iidIPicture.Data4(2) = &H0
  149.     iidIPicture.Data4(3) = &HAA
  150.     iidIPicture.Data4(4) = &H0
  151.     iidIPicture.Data4(5) = &H30
  152.     iidIPicture.Data4(6) = &HC
  153.     iidIPicture.Data4(7) = &HAB
  154.     ' Create picture from icon handle
  155.     OleCreatePictureIndirect picdes, iidIPicture, True, ipic
  156.     ' Result will be valid Picture or Nothing--either way set it
  157.     Set MetafileToPicture = ipic
  158. End Function
  159.  
  160. ' Create a mask on destination DC from source DC of specified size
  161. Function MakeMask(picSrc As StdPicture) As StdPicture
  162.     Dim hdcSrc As Long, hbmpSrc As Long
  163.     Dim hdcDst As Long, hbmpDst As Long
  164.     Dim dxSrc As Long, dySrc As Long
  165.     
  166.     ' Get picture size
  167.     dxSrc = PicXToPixel(picSrc.Width)
  168.     dySrc = PicYToPixel(picSrc.Height)
  169.     
  170.     ' Select source into memory DC
  171.     
  172.     
  173.     ' Create memory device context for destination
  174.     hdcDst = CreateCompatibleDC(0)
  175.     ' Create monochrome bitmap and select it into DC
  176.     hbmpDst = CreateCompatibleBitmap(hdcDst, dxSrc, dySrc)
  177.     hbmpDst = SelectObject(hdcDst, hbmpDst)
  178.     ' Copy color bitmap to DC to create mono mask
  179.     BitBlt hdcDst, 0, 0, dxSrc, dySrc, hdcSrc, 0, 0, SRCCOPY
  180.     ' Clean up
  181.     Call SelectObject(hdcDst, hbmpDst)
  182.     Call DeleteObject(hbmpDst)
  183.     Call DeleteDC(hdcDst)
  184.     
  185.     'Set MakeMask = BitmapToPicture(hbmpDst)
  186. End Function
  187.  
  188. '' Handle information procedures
  189.  
  190. Sub GetIconSize(ByVal hIcon As Long, dx As Long, dy As Long, _
  191.                 Optional xHot As Long, Optional yHot As Long)
  192.     Dim ico As ICONINFO, bmp As BITMAP, dc As Long, f As Boolean
  193.     f = GetIconInfo(hIcon, ico)
  194.     f = GetObjectBitmap(ico.hbmColor, LenB(bmp), bmp)
  195.     dx = bmp.bmWidth
  196.     dy = bmp.bmHeight
  197.     xHot = ico.xHotspot
  198.     yHot = ico.yHotspot
  199. End Sub
  200.  
  201. Sub GetBitmapSize(ByVal hBitmap As Long, dx As Long, dy As Long)
  202.     Dim bmp As BITMAP, f As Boolean
  203.     f = GetObjectBitmap(hBitmap, LenB(bmp), bmp)
  204.     dx = bmp.bmWidth
  205.     dy = bmp.bmHeight
  206. End Sub
  207.  
  208. Function GetShellIconSize() As Long
  209. #If 1 Then
  210.     ' Grabbing size out of registry works, but might change
  211.     Const sMetrics = "Control Panel\Desktop\WindowMetrics"
  212.     GetShellIconSize = MRegTool.GetRegStr(sMetrics, "Shell Icon Size")
  213. #Else
  214.     ' Recommended way of getting size doesn't work until after login
  215.     Dim hImlst As Long, fi As SHFILEINFO, cx As Long, cy As Long
  216.     hImlst = SHGetFileInfo(".", 0, fi, Len(fi), _
  217.                            SHGFI_SYSICONINDEX Or SHGFI_SHELLICONSIZE)
  218.     If ImageList_GetIconSize(hImlst, cx, cy) Then
  219.         GetShellIconSize = cx
  220.     Else
  221.         GetShellIconSize = -1
  222.     End If
  223. #End If
  224. End Function
  225.  
  226. '' Resource helpers
  227.  
  228. Function ResourceIdToStr(ByVal ID As Long) As String
  229.     Select Case ID
  230.     Case RT_CURSOR
  231.         ResourceIdToStr = "CURSOR"
  232.     Case RT_BITMAP
  233.         ResourceIdToStr = "BITMAP"
  234.     Case RT_ICON
  235.         ResourceIdToStr = "ICON"
  236.     Case RT_MENU
  237.         ResourceIdToStr = "MENU"
  238.     Case RT_DIALOG
  239.         ResourceIdToStr = "DIALOG"
  240.     Case RT_STRING
  241.         ResourceIdToStr = "STRING"
  242.     Case RT_FONTDIR
  243.         ResourceIdToStr = "FONTDIR"
  244.     Case RT_FONT
  245.         ResourceIdToStr = "FONT"
  246.     Case RT_ACCELERATOR
  247.         ResourceIdToStr = "ACCELERATOR"
  248.     Case RT_RCDATA
  249.         ResourceIdToStr = "RCDATA"
  250.     Case RT_MESSAGETABLE
  251.         ResourceIdToStr = "MESSAGETABLE"
  252.     Case RT_GROUP_CURSOR
  253.         ResourceIdToStr = "GROUP_CURSOR"
  254.     Case RT_GROUP_ICON
  255.         ResourceIdToStr = "GROUP_ICON"
  256.     Case RT_VERSION
  257.         ResourceIdToStr = "VERSION"
  258.     Case RT_DLGINCLUDE
  259.         ResourceIdToStr = "DLGINCLUDE"
  260.     Case RT_PLUGPLAY
  261.         ResourceIdToStr = "PLUGPLAY"
  262.     Case RT_VXD
  263.         ResourceIdToStr = "VXD"
  264.     Case Else
  265.         ResourceIdToStr = "Unknown"
  266.     End Select
  267. End Function
  268.  
  269. ' The Win32 UnlockResource function is a macro returning zero. Since you
  270. ' can't emulate this in a type library, this do-nothing function is
  271. ' provided here. Better yet, don't try to unlock resources.
  272. Function UnlockResource(ByVal hResData As Long) As Long
  273.     UnlockResource = 0
  274. End Function
  275.  
  276. Function LoadAnyPicture(Optional sPicture As String, _
  277.                         Optional eis As EIconSize = eisDefault _
  278.                         ) As Picture
  279.     Dim hIcon As Long, sExt As String, xy As Long, af As Long
  280.     ' If no picture, return Nothing (clears picture)
  281.     If sPicture = sEmpty Then Exit Function
  282.     ' Use default LoadPicture for all except icons with argument
  283.     sExt = MUtility.GetFileExt(sPicture)
  284.     If UCase$(sExt) <> ".ICO" Or eis = -1 Then
  285.         Set LoadAnyPicture = VB.LoadPicture(sPicture)
  286.         Exit Function
  287.     End If
  288.     
  289.     Select Case eis
  290.     Case eisSmall
  291.         xy = 16: af = LR_LOADFROMFILE
  292.     Case eisHuge
  293.         xy = 48: af = LR_LOADFROMFILE
  294.     Case eisImage
  295.         xy = 0: af = LR_LOADFROMFILE
  296.     Case eisShell ' Get icon size from system
  297.         xy = GetShellIconSize(): af = LR_LOADFROMFILE
  298.     Case Is > 0   ' Use arbitrary specified size--72 by 72 or whatever
  299.         xy = eis: af = LR_LOADFROMFILE
  300.     Case Else     ' Includes eisDefault
  301.         xy = 0: af = LR_LOADFROMFILE Or LR_DEFAULTSIZE
  302.     End Select
  303.     hIcon = LoadImage(0&, sPicture, IMAGE_ICON, xy, xy, af)
  304.     ' If this fails, use original load
  305.     If hIcon <> hNull Then
  306.         Set LoadAnyPicture = IconToPicture(hIcon)
  307.     Else
  308.         Set LoadAnyPicture = VB.LoadPicture(sPicture)
  309.     End If
  310. End Function
  311.  
  312. Function LoadAnyResPicture(vRes As Variant, iResType As Integer, _
  313.                            Optional eis As EIconSize = eisDefault _
  314.                            ) As Picture
  315.     Dim hIcon As Long, sExt As String, xy As Long, af As Long
  316.     ' Can't use LoadImage in environment--have to make do with default
  317.     If Not MUtility.IsExe() Then
  318.         If (eis = -1) Or (iResType <> vbResIcon) Then
  319.             Set LoadAnyResPicture = VB.LoadResPicture(vRes, iResType)
  320.             Exit Function
  321.         End If
  322.     End If
  323.     
  324.     Select Case eis
  325.     Case eisSmall
  326.         xy = 16: af = LR_LOADFROMFILE
  327.     Case eisHuge
  328.         xy = 48: af = LR_LOADFROMFILE
  329.     Case eisImage
  330.         xy = 0: af = LR_LOADFROMFILE
  331.     Case eisShell   ' Get icon size from system
  332.         xy = GetShellIconSize(): af = LR_LOADFROMFILE
  333.     Case Is > 0     ' Use arbitrary specified size--72 by 72 or whatever
  334.         xy = eis: af = LR_LOADFROMFILE
  335.     Case Else       ' Includes eisDefault
  336.         xy = 0: af = LR_LOADFROMFILE Or LR_DEFAULTSIZE
  337.     End Select
  338.     If TypeName(vRes) = "String" Then
  339.         hIcon = LoadImage(App.hInstance, CStr(vRes), IMAGE_ICON, xy, xy, af)
  340.     Else
  341.         hIcon = LoadImage(App.hInstance, CLng(vRes), IMAGE_ICON, xy, xy, af)
  342.     End If
  343.     If hIcon <> hNull Then
  344.         Set LoadAnyResPicture = IconToPicture(hIcon)
  345.     Else
  346.         Set LoadAnyResPicture = VB.LoadResPicture(vRes, iResType)
  347.     End If
  348. End Function
  349.  
  350. #If fComponent = 0 Then
  351. Private Sub ErrRaise(e As Long)
  352.     Dim sText As String, sSource As String
  353.     If e > 1000 Then
  354.         sSource = App.ExeName & ".PicTool"
  355.         Select Case e
  356.         Case eeBasePicTool
  357.             BugAssert True
  358.        ' Case ee...
  359.        '     Add additional errors
  360.         End Select
  361.         Err.Raise COMError(e), sSource, sText
  362.     Else
  363.         ' Raise standard Visual Basic error
  364.         sSource = App.ExeName & ".VBError"
  365.         Err.Raise e, sSource
  366.     End If
  367. End Sub
  368. #End If
  369.  
  370.